home *** CD-ROM | disk | FTP | other *** search
/ Developer CD Series 1993…ch: Other People's Memory / ADC Developer CD (1993-03) (''Other People's Memory'')_iso / Dev.CD Mar 93.iso / Development Platforms / LISP Related / LISP Goodies / AV Parser / AV Program / lalr parser.lisp < prev    next >
Encoding:
Text File  |  1992-09-02  |  17.0 KB  |  449 lines  |  [TEXT/CCL2]
  1. ;;; -*- package: LALR -*-
  2. ;;;
  3. ;;;  This is an LALR parser generator.
  4. ;;;  (c) 1988 Mark Johnson.
  5. ;;;  This is *not* the property of Xerox Corporation!
  6.  
  7. ;;;  Modified to cache the first terminals, the epsilon derivations
  8. ;;;  the rules that expand a category, and the items that expand
  9. ;;;  a category
  10.  
  11. (defpackage "LALR"
  12.   (:use "COMMON-LISP")
  13.   (:export make-parser lalr-parser *lalr-debug* grammar lexforms $ parse)
  14.   ; (:shadow first rest)
  15.   )
  16.  
  17. (in-package "LALR")
  18.  
  19. #|
  20. (defmacro first (x) `(car ,x))        ; Not needed by MCL 2.0 (Hurray!)
  21. (defmacro rest (x) `(cdr ,x))
  22. |#
  23.  
  24. ;;;  The external interface is MAKE-PARSER.  It takes three arguments, a
  25. ;;;  CFG grammar, a list of the lexical or terminal categories, and an
  26. ;;;  atomic end marker.  It produces a list which is the Lisp code for
  27. ;;;  an LALR(1) parser for that grammar.  If that list is compiled, then
  28. ;;;  the function LALR-PARSER is defined.  LALR-PARSER is a function with 
  29. ;;;  two arguments, NEXT-INPUT and PARSE-ERROR. 
  30. ;;;
  31. ;;;  The first argument to LALR-PARSER, NEXT-INPUT must be a function with 
  32. ;;;  zero arguments; every time NEXT-INPUT is called it should return
  33. ;;;  a CONS cell, the CAR of which is the category of the next lexical
  34. ;;;  form in the input and the CDR of which is the value of that form.
  35. ;;;  Each call to NEXT-INPUT should advance one lexical item in the
  36. ;;;  input.  When the input is consumed, NEXT-INPUT should return a
  37. ;;;  CONS whose CAR is the atomic end marker used in the call to MAKE-PARSER.
  38. ;;;
  39. ;;;  The second argument to LALR-PARSER, PARSE-ERROR will be called
  40. ;;;  if the parse fails because the input is ill-formed.
  41.  
  42. ;;; definitions of constants and global variables used
  43.  
  44. (defconstant *TOPCAT* '$Start)
  45. (defvar      *ENDMARKER*)
  46. (defvar      glex)
  47. (defvar      grules)
  48. (defvar      gstart)
  49. (defvar      gstarts)
  50. (defvar      gcats)
  51. (defvar      gfirsts)
  52. (defvar      gepsilons)
  53. (defvar      gexpansions)
  54. (defvar      *lalr-debug* NIL "Inserts debugging code into parser if non-NIL")
  55. (defvar      stateList '())
  56.  
  57. (defun make-parser (grammar lex endMarker)
  58.   "Takes a grammar and produces the Lisp code for a parser for that grammar"
  59.   (setq *ENDMARKER* endMarker)
  60.  
  61.   ;;;  cache some data that will be useful later
  62.   (setq glex lex)
  63.   (setq gstart (caar grammar))
  64.   (setq grules (let ((i 0)) 
  65.                  (mapcar #'(lambda (r) (transformRule r (incf i)))
  66.                          grammar)))
  67.   (setq gcats (getallcats))
  68.   (setq gexpansions (mapcar #'(lambda (cat)
  69.                                 (cons cat (compute-expansion cat)))
  70.                             gcats))
  71.   (setq gepsilons (remove-if-not #'derivesEps gcats))
  72.   (setq gstarts (cons (list *ENDMARKER* *ENDMARKER*)
  73.                       (mapcar #'(lambda (cat)
  74.                                   (cons cat (firstTerms (list cat))))
  75.                               gcats)))
  76.  
  77.   ;;; now actually build the parser
  78.   (buildTable)
  79.   (when (and (listp *lalr-debug*) (member 'print-table *lalr-debug*))
  80.     (Print-Table stateList))
  81.   (buildParser))
  82.  
  83. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  84. ;;;
  85. ;;;                    Rules and Grammars
  86. ;;;
  87.  
  88. (defstruct rule no mother daughters action)
  89.  
  90. (defun transformRule (rule no)
  91.   (make-rule :no no
  92.              :mother (first rule)
  93.              :daughters (butlast (cddr rule))
  94.              :action (car (last rule))))
  95.  
  96. (defun compute-expansion (cat)
  97.   (remove-if-not #'(lambda (rule)
  98.                      (eq (rule-mother rule) cat))
  99.                  grules))
  100.  
  101. (defmacro expand (cat)
  102.   `(cdr (assoc ,cat gexpansions)))
  103.  
  104. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  105. ;;;
  106. ;;;                    Properties of grammars
  107.  
  108. (defun GetAllCats ()
  109.   (labels ((try (dejaVu cat)
  110.                 (if (find cat dejaVu)
  111.                   dejaVu
  112.                   (tryRules (cons cat dejaVu) (compute-expansion cat))))
  113.            (tryRules (dejaVu rules)
  114.                      (if rules
  115.                        (tryRules (tryCats dejaVu (rule-daughters (car rules)))
  116.                                  (cdr rules))
  117.                        dejaVu))
  118.            (tryCats (dejaVu cats)
  119.                     (if cats
  120.                       (tryCats (try dejaVu (car cats)) (cdr cats))
  121.                       dejaVu)))
  122.     (try '() gstart)))
  123.  
  124. (defun derivesEps (c)
  125.   "t if c can be rewritten as the null string"
  126.   (labels ((try (dejaVu cat)
  127.              (unless (find cat dejaVu)
  128.                (some #'(lambda (r) 
  129.                          (every #'(lambda (c1) (try (cons cat dejaVu) c1))
  130.                                 (rule-daughters r)))
  131.                      (expand cat)))))
  132.     (try '() c)))
  133.  
  134. (defun derivesEpsilon (c)
  135.   "looks up the cache to see if c derives the null string"
  136.   (member c gepsilons))
  137.  
  138. (defun FirstTerms (catList)
  139.   "the leading terminals of an expansion of catList"
  140.   (labels ((firstDs (cats)
  141.                     (if cats
  142.                       (if (derivesEpsilon (car cats))
  143.                         (cons (car cats) (firstDs (cdr cats)))
  144.                         (list (car cats)))))
  145.            (try (dejaVu cat)
  146.                 (if (member cat dejaVu)
  147.                   dejaVu
  148.                   (tryList (cons cat dejaVu) 
  149.                            (mapcan #'(lambda (r) 
  150.                                        (firstDs (rule-daughters r)))
  151.                                    (expand cat)))))
  152.            (tryList (dejaVu cats)
  153.                     (if cats
  154.                       (tryList (try dejaVu (car cats)) (cdr cats))
  155.                       dejaVu)))
  156.     (remove-if-not #'(lambda (term)
  157.                        (or (eq *ENDMARKER* term)
  158.                            (find term glex))) 
  159.                    (tryList '() (firstDs catList)))))
  160.  
  161. (defun FirstTerminals (catList)
  162.   (if catList
  163.     (if (derivesEpsilon (first catList))
  164.       (union (cdr (assoc (first catList) gstarts))
  165.              (FirstTerminals (rest catList)))
  166.       (cdr (assoc (first catList) gstarts)))
  167.     '()))
  168.  
  169.  
  170. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  171. ;;;
  172. ;;;                  LALR(1) parsing table constructor
  173. ;;;
  174.  
  175. (defstruct item rule pos la)
  176.  
  177. (defmacro item-daughters (i) `(rule-daughters (item-rule ,i)))
  178.  
  179. (defmacro item-right (i) `(nthcdr (item-pos ,i) (item-daughters ,i)))
  180.  
  181. (defmacro item-equal (i1 i2)
  182.   `(and (eq (item-rule ,i1) (item-rule ,i2))
  183.         (= (item-pos ,i1) (item-pos ,i2))
  184.         (eq (item-la ,i1) (item-la ,i2))))
  185.  
  186. (defmacro item-core-equal (c1 c2)
  187.   "T if the cores of c1 and c2 are equal"
  188.   `(and (eq (item-rule ,c1) (item-rule ,c2))
  189.         (= (item-pos ,c1) (item-pos ,c2))))
  190.  
  191. (defun close-items (items)    
  192.   "computes the closure of a set of items"
  193.   (do ((toDo items))
  194.       ((null toDo) items)
  195.     (let ((i (pop toDo)))
  196.       (when (item-right i)
  197.         (dolist (la (FirstTerminals (append (rest (item-right i))
  198.                                             (list (item-la i)))))
  199.           (dolist (r (expand (first (item-right i))))
  200.               (unless (dolist (i items)
  201.                         (if (and (eq r (item-rule i))
  202.                                  (= (item-pos i) 0)
  203.                                  (eq (item-la i) la))
  204.                           (return t)))
  205.                 (let ((new (make-item :rule r :pos 0 :la la)))
  206.                   (push new items)
  207.                   (push new toDo)))))))))
  208.  
  209. (defun shift-items (items cat)
  210.   "shifts a set of items over cat"
  211.   (labels ((shift-item (item)
  212.                        (if (eq (first (item-right item)) cat)
  213.                          (make-item :rule (item-rule item)
  214.                                     :pos (1+ (item-pos item))
  215.                                     :la (item-la item)))))
  216.     (let ((new-items '()))
  217.       (dolist (i items)
  218.         (let ((n (shift-item i)))
  219.           (if n
  220.             (push n new-items))))
  221.       new-items)))
  222.  
  223. (defun items-right (items)
  224.   "returns the set of categories appearing to the right of the dot"
  225.   (let ((right '()))
  226.     (dolist (i items)
  227.       (let ((d (first (item-right i))))
  228.         (if (and d (not (find d right)))
  229.           (push d right))))
  230.     right))
  231.  
  232. (defun compact-items (items)
  233.   "collapses items with the same core to compact items" 
  234.   (let ((soFar '()))
  235.     (dolist (i items)
  236.       (let ((ci (dolist (s soFar)
  237.                   (if (item-core-equal s i)
  238.                     (return s)))))
  239.         (if ci
  240.           (push (item-la i) (item-la ci))
  241.           (push (make-item :rule (item-rule i)
  242.                            :pos (item-pos i)
  243.                            :la (list (item-la i)))
  244.                 soFar))))
  245.     (sort soFar #'< 
  246.           :key #'(lambda (i) (rule-no (item-rule i))))))
  247.  
  248. (defmacro expand-citems (citems)
  249.   "expands a list of compact items into items"
  250.   `(let ((items '()))
  251.      (dolist (ci ,citems)
  252.        (dolist (la (item-la ci))
  253.          (push (make-item :rule (item-rule ci)
  254.                           :pos (item-pos ci)
  255.                           :la la)
  256.                items)))
  257.      items))
  258.  
  259. (defun subsumes-citems (ci1s ci2s)
  260.   "T if the sorted set of items ci2s subsumes the sorted set ci1s"
  261.   (and (= (length ci1s) (length ci2s))
  262.        (every #'(lambda (ci1 ci2)
  263.                   (and (item-core-equal ci1 ci2)
  264.                        (subsetp (item-la ci1) (item-la ci2))))
  265.               ci1s ci2s)))
  266.  
  267. (defun merge-citems (ci1s ci2s)
  268.   "Adds the las of ci1s to ci2s.  ci2s should subsume ci1s"
  269.   (mapcar #'(lambda (ci1 ci2)
  270.               (setf (item-la ci2) (nunion (item-la ci1) (item-la ci2))))
  271.           ci1s ci2s)
  272.   ci2s)
  273.  
  274. ;;;  The actual table construction functions
  275.  
  276. (defstruct state name citems shifts conflict)
  277. (defstruct shift cat where)
  278.  
  279. (defparameter nextStateNo -1)
  280.  
  281. (defun lookup (citems)
  282.   "finds a state with the same core items as citems if it exits"
  283.   (find-if #'(lambda (state)
  284.                (and (= (length citems) (length (state-citems state)))
  285.                     (every #'(lambda (ci1 ci2)
  286.                                (item-core-equal ci1 ci2))
  287.                            citems (state-citems state))
  288.                     ))
  289.            stateList))
  290.  
  291. (defun addState (citems)
  292.   "creates a new state and adds it to the state list"
  293.   (let ((newState 
  294.          (make-state :name (intern (format nil "STATE-~D" (incf nextStateNo)))
  295.                      :citems citems)))
  296.     (push newState stateList)
  297.     newState))
  298.  
  299. (defun getStateName (items)
  300.   "returns the state name for this set of items"
  301.   (let* ((citems (compact-items items))
  302.          (state (lookup citems)))
  303.     (cond ((null state)
  304.            (setq state (addState citems))
  305.            (buildState state items))
  306.           ((subsumes-citems citems (state-citems state))
  307.            nil)
  308.           (t
  309.            (merge-citems citems (state-citems state))
  310.            (followState items)))
  311.     (state-name state)))
  312.  
  313.       
  314. (defun buildState (state items)
  315.   "creates the states that this state can goto"
  316.   (let ((closure (close-items items)))
  317.     (dolist (cat (items-right closure))
  318.       (push (make-shift :cat cat
  319.                         :where (getStateName (shift-items closure cat)))
  320.             (state-shifts state)))))
  321.  
  322. (defun followState (items)
  323.   "percolates look-ahead onto descendant states of this state"
  324.   (let ((closure (close-items items)))
  325.     (dolist (cat (items-right closure))
  326.       (getStateName (shift-items closure cat)))))
  327.  
  328. (defun buildTable ()
  329.   "Actually builds the table"
  330.   (setq stateList '())
  331.   (setq nextStateNo -1)
  332.   (getStateName (list (make-item :rule (make-rule :no 0
  333.                                                   :mother *TOPCAT*
  334.                                                   :daughters (list gstart))
  335.                                  :pos 0
  336.                                  :la *ENDMARKER*)))
  337.   (setq stateList (nreverse stateList)))
  338.   
  339. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  340. ;;;
  341. ;;;                  LALR(1) parsing table printer
  342. ;;;
  343.  
  344. (defun Print-Table (stateList)
  345.   "Prints the state table"
  346.   (dolist (state stateList)
  347.     (format t "~%~%~a:" (state-name state))
  348.     (dolist (citem (state-citems state))
  349.       (format t "~%  ~a -->~{ ~a~} .~{ ~a~}, ~{~a ~}"
  350.               (rule-mother (item-rule citem))
  351.               (subseq (rule-daughters (item-rule citem)) 0 (item-pos citem))
  352.               (subseq (rule-daughters (item-rule citem)) (item-pos citem))
  353.               (item-la citem)))
  354.     (dolist (shift (state-shifts state))
  355.       (format t "~%    On ~a shift ~a" (shift-cat shift) (shift-where shift)))
  356.     (dolist (reduce (compact-items 
  357.                      (delete-if #'(lambda (i) (item-right i))
  358.                                 (close-items 
  359.                                  (expand-citems (state-citems state))))))
  360.       (format t "~%    On~{ ~a~} reduce~{ ~a~} --> ~a"
  361.               (item-la reduce)
  362.               (rule-daughters (item-rule reduce))
  363.               (rule-mother (item-rule reduce)))))
  364.   (format t "~%"))
  365.  
  366. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  367. ;;;
  368. ;;;                  LALR(1) parser constructor
  369. ;;;
  370.  
  371. (defun translateState (state)
  372.   "translates a state into lisp code that could appear in a labels form"
  373.   (let ((reduces (compact-items 
  374.                   (delete-if #'(lambda (i) (item-right i))
  375.                              (close-items 
  376.                               (expand-citems (state-citems state))))))
  377.         (symbolsSoFar '()))   ; to ensure that a symbol never occurs twice
  378.        (labels ((translateShift (shift)
  379.                                 (push (shift-cat shift) symbolsSoFar)
  380.                                 `(,(shift-cat shift)
  381.                                   ,@(when *lalr-debug*
  382.                                       `((when *lalr-debug*
  383.                                           (princ ,(format nil "Shift ~a to ~a~%" 
  384.                                                           (shift-cat shift) (shift-where shift))))))
  385.                                   (shift-from #',(state-name state))
  386.                                   (,(shift-where shift))))
  387.                 (translateReduce (item)
  388.                                  (when (intersection (item-la item) symbolsSoFar)
  389.                                    (format t "Warning, Not LALR(1)!!: ~a, ~a --> ~{~a ~}~%"
  390.                                            (state-name state) 
  391.                                            (rule-mother (item-rule item))
  392.                                            (rule-daughters (item-rule item)))
  393.                                    (setf (item-la item) 
  394.                                          (nset-difference (item-la item) 
  395.                                                           symbolsSoFar)))
  396.                                  (dolist (la (item-la item))
  397.                                    (push la symbolsSoFar))
  398.                                  `(,(item-la item)
  399.                                    ,@(when *lalr-debug*
  400.                                        `((when *lalr-debug*
  401.                                            (princ ,(format nil "Reduce ~{~a ~} --> ~a~%"
  402.                                                            (rule-daughters (item-rule item))
  403.                                                            (rule-mother (item-rule item)))))))
  404.                                    (reduce-cat #',(state-name state)
  405.                                                ',(rule-mother (item-rule item))
  406.                                                ,(item-pos item)
  407.                                                ,(rule-action (item-rule item))))))
  408.          `(,(state-name state) ()
  409.            (case (input-peek)
  410.              ,@(mapcar #'translateShift (state-shifts state))
  411.              ,@(mapcar #'translateReduce reduces)
  412.              (otherwise (funcall parse-error)))))))
  413.  
  414. ;;;  next-input performs lexical analysis.  It must return a cons cell.
  415. ;;;  its car holds the category, its cdr the value.
  416.  
  417. (defun buildParser ()
  418.   "returns an lalr(1) parser.  next-input must return 2 values!"
  419.   `(defun lalr-parser (next-input parse-error)
  420.      (let ((cat-la '())          ; category lookahead
  421.            (val-la '())          ; value lookahead
  422.            (val-stack '())       ; value stack
  423.            (state-stack '()))    ; state stack
  424.        (labels ((input-peek ()
  425.                             (unless cat-la
  426.                               (let ((new (funcall next-input)))
  427.                                 (setq cat-la (list (car new)))
  428.                                 (setq val-la (list (cdr new)))))
  429.                             (first cat-la))
  430.                 (shift-from (name)
  431.                             (push name state-stack)
  432.                             (pop cat-la)
  433.                             (push (pop val-la) val-stack))
  434.                 (reduce-cat (name cat ndaughters action)
  435.                             (if (eq cat ',*TOPCAT*)
  436.                               (pop val-stack)
  437.                               (let ((daughter-values '())
  438.                                     (state name))
  439.                                 (dotimes (i ndaughters)
  440.                                   (push (pop val-stack) daughter-values)
  441.                                   (setq state (pop state-stack)))
  442.                                 (push cat cat-la)
  443.                                 (push (apply action daughter-values) val-la)
  444.                                 (funcall state))))
  445.                 ,@(mapcar #'translateState stateList))
  446.          (,(state-name (first stateList)))))))
  447.                 
  448.  
  449.